home *** CD-ROM | disk | FTP | other *** search
/ Meeting Pearls 4 / Meeting Pearls Vol. IV (1996)(GTI - Schatztruhe)[!].iso / Pearls / dev / Oberon / OberonV4 / system / Kepler1.Mod (.txt) < prev    next >
Oberon Text  |  1995-06-12  |  13KB  |  393 lines
  1. Syntax10.Scn.Fnt
  2. MODULE Kepler1;    (* J. Templ, 5.11.90/27.09.93 *)
  3.     IMPORT
  4.         KeplerGraphs, KeplerFrames, KeplerPorts, Math, Oberon, Texts, Files, Fonts, Display, In;
  5.     CONST
  6.         ArrLen = 44; ArrAngle = Math.pi / 6;    (*30 DEG*)
  7.         fg = Display.white;
  8.     TYPE
  9.         Rectangle* = POINTER TO RectangleDesc;
  10.         RectangleDesc* = RECORD
  11.             (KeplerGraphs.ConsDesc)
  12.         END ;
  13.         Texture* = POINTER TO TextureDesc;
  14.         TextureDesc* = RECORD
  15.             (KeplerGraphs.ConsDesc)
  16.             pat*: INTEGER;
  17.         END ;
  18.         Line* = POINTER TO LineDesc;
  19.         LineDesc* = RECORD
  20.             (KeplerGraphs.ConsDesc)
  21.         END ;
  22.         Circle* = POINTER TO CircleDesc;
  23.         CircleDesc* = RECORD
  24.             (KeplerGraphs.ConsDesc)
  25.         END ;
  26.         Ellipse* = POINTER TO EllipseDesc;
  27.         EllipseDesc* = RECORD
  28.             (KeplerGraphs.ConsDesc)
  29.         END ;
  30.         String* = POINTER TO StringDesc;    (*for backward compatibility only*)
  31.         StringDesc* = RECORD
  32.             (KeplerFrames.CaptionDesc)
  33.         END ;
  34.         HShape* = POINTER TO HShapeDesc;
  35.         HShapeDesc* = RECORD
  36.             (KeplerGraphs.ConsDesc)
  37.         END ;
  38.         H90Shape* = POINTER TO H90ShapeDesc;
  39.         H90ShapeDesc* = RECORD
  40.             (KeplerGraphs.ConsDesc)
  41.         END ;
  42.         AttrLine* = POINTER TO AttrDesc;
  43.         AttrDesc* = RECORD
  44.             (KeplerGraphs.ConsDesc)
  45.             width*, a1*, a2*: INTEGER; (* line width, arrow kind, 0= no arrow, 1 = norm arrow *)
  46.         END ;
  47.         Triangle* = POINTER TO TriangleDesc;
  48.         TriangleDesc* = RECORD
  49.             (KeplerGraphs.ConsDesc)
  50.             pat*: INTEGER
  51.         END ;
  52. (* ------------------------------- Rectangle ------------------------------- *)
  53.     PROCEDURE MinMax(x, y: INTEGER; VAR min, max: INTEGER);
  54.     BEGIN IF x < y THEN min := x; max := y ELSE min := y; max := x END
  55.     END MinMax;
  56.     PROCEDURE (R: Rectangle) Draw* (F: KeplerPorts.Port);
  57.         VAR minx, maxx, miny, maxy: INTEGER;
  58.     BEGIN
  59.         MinMax(R.p[0].x, R.p[1].x, minx, maxx);
  60.         MinMax(R.p[0].y, R.p[1].y, miny, maxy);
  61.         F.DrawRect(minx, miny, maxx-minx, maxy-miny, Display.white, Display.replace)
  62.     END Draw;
  63.     PROCEDURE NewRectangle*;
  64.         VAR o: Rectangle;
  65.     BEGIN
  66.         IF KeplerFrames.nofpts >= 2 THEN
  67.             NEW(o); o.nofpts := 2;
  68.             KeplerFrames.ConsumePoint(o.p[0]);
  69.             KeplerFrames.ConsumePoint(o.p[1]);
  70.             KeplerFrames.Focus.Append(o);
  71.         END
  72.     END NewRectangle;
  73. (* ------------------------------- Texture ------------------------------- *)
  74.     PROCEDURE (T: Texture) Draw* (F: KeplerPorts.Port);
  75.         VAR minx, maxx, miny, maxy: INTEGER;
  76.     BEGIN
  77.         MinMax(T.p[0].x, T.p[1].x, minx, maxx);
  78.         MinMax(T.p[0].y, T.p[1].y, miny, maxy);
  79.         F.FillRect(minx, miny, maxx-minx, maxy-miny, Display.white, T.pat, Display.replace)
  80.     END Draw;
  81.     PROCEDURE (T: Texture) Write* (VAR R: Files.Rider);
  82.     BEGIN Files.WriteNum(R, T.pat); T.Write^(R)
  83.     END Write;
  84.     PROCEDURE (T: Texture) Read* (VAR R: Files.Rider);
  85.         VAR i: LONGINT;
  86.     BEGIN Files.ReadNum(R, i); T.pat := SHORT (i); T.Read^(R)
  87.     END Read;
  88.     PROCEDURE NewTexture*;
  89.         VAR o: Texture; i: INTEGER;
  90.     BEGIN
  91.         IF KeplerFrames.nofpts >= 2 THEN
  92.             In.Open; In.Int(i);
  93.             IF In.Done THEN NEW(o); o.nofpts := 2; o.pat := i;
  94.                 KeplerFrames.ConsumePoint(o.p[0]);
  95.                 KeplerFrames.ConsumePoint(o.p[1]);
  96.                 KeplerFrames.Focus.Append(o)
  97.             END
  98.         END
  99.     END NewTexture;
  100. (* ------------------------------- Line ------------------------------- *)
  101.     PROCEDURE (L: Line) Draw* (F: KeplerPorts.Port);
  102.     BEGIN F.DrawLine(L.p[0].x, L.p[0].y, L.p[1].x, L.p[1].y, Display.white, Display.replace)
  103.     END Draw;
  104.     PROCEDURE NewLine*;
  105.         VAR o: Line;
  106.     BEGIN
  107.         IF KeplerFrames.nofpts >= 2 THEN
  108.             NEW(o); o.nofpts := 2;
  109.             KeplerFrames.ConsumePoint(o.p[0]);
  110.             KeplerFrames.ConsumePoint(o.p[1]);
  111.             KeplerFrames.Focus.Append(o);
  112.         END
  113.     END NewLine;
  114. (* ------------------------------- Circle ------------------------------- *)
  115.     PROCEDURE (C: Circle) Draw* (F: KeplerPorts.Port);
  116.         VAR a, b: LONGINT; r: INTEGER;
  117.     BEGIN
  118.         a := C.p[0].x - C.p[1].x; b := C.p[0].y - C.p[1].y;
  119.         r := SHORT(ENTIER(Math.sqrt(a*a + b*b)));
  120.         F.DrawCircle(C.p[0].x, C.p[0].y, r, Display.white, Display.replace)
  121.     END Draw;
  122.     PROCEDURE NewCircle*;
  123.         VAR o: Circle;
  124.     BEGIN
  125.         IF KeplerFrames.nofpts >= 2 THEN
  126.             NEW(o); o.nofpts := 2;
  127.             KeplerFrames.ConsumePoint(o.p[0]);
  128.             KeplerFrames.ConsumePoint(o.p[1]);
  129.             KeplerFrames.Focus.Append(o);
  130.         END
  131.     END NewCircle;
  132. (* ------------------------------- Ellipse ------------------------------- *)
  133.     PROCEDURE (E: Ellipse) Draw* (F: KeplerPorts.Port);
  134.         VAR a, b, tmpx, tmpy, temp : INTEGER; 
  135.     BEGIN
  136.         tmpx := E.p[1].x - E.p[0].x; tmpy := E.p[2].y - E.p[0].y;
  137.         MinMax( tmpx, -tmpx, temp, a );
  138.         MinMax( tmpy, -tmpy, temp, b );
  139.         E.p[2].x := E.p[0].x;
  140.         E.p[1].y := E.p[0].y;
  141.         F.DrawEllipse(E.p[0].x, E.p[0].y, a, b, Display.white, Display.replace)
  142.     END Draw;
  143.     PROCEDURE NewEllipse*;
  144.         VAR o: Ellipse;
  145.     BEGIN
  146.         IF KeplerFrames.nofpts >= 3 THEN
  147.             NEW(o); o.nofpts := 3;
  148.             KeplerFrames.ConsumePoint(o.p[0]);
  149.             KeplerFrames.ConsumePoint(o.p[1]);
  150.             KeplerFrames.ConsumePoint(o.p[2]);
  151.             KeplerFrames.Focus.Append(o);
  152.         END
  153.     END NewEllipse;
  154. (* ------------------------------- Captions ------------------------------- *)
  155.     PROCEDURE NewString*;        (*for backward compatibility only*)
  156.         VAR o: KeplerFrames.Caption;
  157.             beg, end, time: LONGINT;
  158.             R: Texts.Reader;
  159.             T: Texts.Text;
  160.             i: INTEGER;
  161.             ch: CHAR;
  162.     BEGIN
  163.         IF KeplerFrames.nofpts >= 1 THEN
  164.             Oberon.GetSelection(T, beg, end, time);
  165.             IF time > 0 THEN 
  166.                 NEW(o); o.nofpts := 1;
  167.                 In.Open; In.Int(i);
  168.                 IF ~In.Done THEN o.align := 0 ELSE o.align := SHORT(i) END ;
  169.                 KeplerFrames.ConsumePoint(o.p[0]);
  170.                 Texts.OpenReader(R, T, beg); Texts.Read(R, ch);
  171.                 o.fnt := R.fnt; i := 0;
  172.                 WHILE (ch >= " ") & (i < 128) & (Texts.Pos(R) <= end)  DO
  173.                     o.s[i] := ch; INC(i);
  174.                     Texts.Read(R, ch)
  175.                 END ;
  176.                 o.s[i] := 0X;
  177.                 KeplerFrames.Focus.Append(o)
  178.             END
  179.         END
  180.     END NewString;
  181.     PROCEDURE ChangeFont*;
  182.         VAR G: KeplerGraphs.Graph; c: KeplerGraphs.Constellation;
  183.             fntname: ARRAY 32 OF CHAR;
  184.             fnt: Fonts.Font;
  185.             F: KeplerPorts.BalloonPort;
  186.     BEGIN
  187.         In.Open;
  188.         In.Name(fntname);
  189.         KeplerFrames.GetSelection(G);
  190.         IF (G # NIL) & In.Done THEN 
  191.             fnt := Fonts.This(fntname);
  192.             IF fntname = fnt.name THEN
  193.                 NEW(F); KeplerPorts.InitBalloon(F);
  194.                 c := G.cons;
  195.                 WHILE c # NIL DO
  196.                     WITH c: KeplerFrames.Caption DO
  197.                         IF c.State() = 2 THEN c.Draw(F); c.fnt := fnt; c.Draw(F) END
  198.                     ELSE
  199.                     END ;
  200.                     c := c.next
  201.                 END ;
  202.                 G.notify(KeplerGraphs.restore, G, NIL, F)
  203.             END 
  204.         END
  205.     END ChangeFont;
  206.     PROCEDURE ChangeAlign*;
  207.         VAR G: KeplerGraphs.Graph; c: KeplerGraphs.Constellation;
  208.             align: INTEGER;
  209.             F: KeplerPorts.BalloonPort;
  210.     BEGIN
  211.         In.Open; In.Int(align);
  212.         KeplerFrames.GetSelection(G);
  213.         IF (G # NIL) & In.Done THEN 
  214.             IF (0 <= align) & (align <= 6) THEN
  215.                 NEW(F); KeplerPorts.InitBalloon(F);
  216.                 c := G.cons;
  217.                 WHILE c # NIL DO
  218.                     WITH c: KeplerFrames.Caption DO
  219.                         IF c.State() = 2 THEN c.Draw(F); c.align := SHORT(align); c.Draw(F) END
  220.                     ELSE
  221.                     END ;
  222.                     c := c.next
  223.                 END ;
  224.                 G.notify(KeplerGraphs.restore, G, NIL, F)
  225.             END 
  226.         END
  227.     END ChangeAlign;
  228. (* ------------------------------- HShape ------------------------------- *)
  229.     PROCEDURE (self: HShape) Draw* (F: KeplerPorts.Port);
  230.     BEGIN F.DrawLine(self.p[0].x, self.p[1].y, self.p[2].x, self.p[1].y, Display.white, Display.replace)
  231.     END Draw;
  232.     PROCEDURE NewHShape*;
  233.         VAR h: HShape;
  234.     BEGIN
  235.         IF KeplerFrames.nofpts >= 3 THEN
  236.             NEW(h); h.nofpts := 3;
  237.             KeplerFrames.ConsumePoint(h.p[0]);
  238.             KeplerFrames.ConsumePoint(h.p[1]);
  239.             KeplerFrames.ConsumePoint(h.p[2]);
  240.             KeplerFrames.Focus.Append(h)
  241.         END
  242.     END NewHShape;
  243. (* ------------------------------- H90Shape ------------------------------- *)
  244.     PROCEDURE (self: H90Shape) Draw* (F: KeplerPorts.Port);
  245.     BEGIN F.DrawLine(self.p[1].x, self.p[0].y, self.p[1].x, self.p[2].y, Display.white, Display.replace)
  246.     END Draw;
  247.     PROCEDURE NewH90Shape*;
  248.         VAR h: H90Shape;
  249.     BEGIN
  250.         IF KeplerFrames.nofpts >= 3 THEN
  251.             NEW(h); h.nofpts := 3;
  252.             KeplerFrames.ConsumePoint(h.p[0]);
  253.             KeplerFrames.ConsumePoint(h.p[1]);
  254.             KeplerFrames.ConsumePoint(h.p[2]);
  255.             KeplerFrames.Focus.Append(h)
  256.         END
  257.     END NewH90Shape;
  258. (* ------------------------------- AttrLine ------------------------------- *)
  259.     PROCEDURE Sign ( x : LONGINT ) : INTEGER;
  260.     BEGIN IF x < 0 THEN RETURN - 1 ELSE RETURN 1 END
  261.     END Sign;
  262.     PROCEDURE GetPoint2 ( x, y, dx, dy : LONGINT; angle : REAL; VAR aX, aY : INTEGER; ArrLen: INTEGER );
  263.         VAR h, s : LONGINT; cos, t: REAL;
  264.     BEGIN
  265.         aX := SHORT(x - ENTIER (Math.cos ( angle ) * ArrLen + 0.5) * Sign ( dx ));
  266.         aY := SHORT(y - ENTIER ( Math.sin ( angle ) * ArrLen + 0.5 ) * Sign ( dx ));
  267.     END GetPoint2;
  268.     PROCEDURE DrawArrow (F: KeplerPorts.Port; x1, y1, x2, y2 : LONGINT; ArrLen: INTEGER; ArrAngle: REAL);
  269.         CONST MinLen = 40;
  270.         VAR angle : REAL; dx, dy : LONGINT; ax1, ay1, ax2, ay2: INTEGER;
  271.     BEGIN
  272.         IF ArrLen < MinLen THEN ArrLen := MinLen END ;
  273.         dx := x2 - x1; dy := y2 - y1;
  274.         IF dx # 0 THEN angle := Math.arctan ( dy / dx ) ELSE angle := Sign ( dy ) * ( Math.pi / 2 ) END;
  275.         GetPoint2 ( x2, y2, dx, dy, angle - ArrAngle / 2, ax1, ay1, ArrLen );
  276.         GetPoint2 ( x2, y2, dx, dy, angle + ArrAngle / 2, ax2, ay2, ArrLen );
  277.         F.FillQuad(ax1, ay1, SHORT(x2), SHORT(y2), ax2, ay2, ax2, ay2, fg, 5, Display.replace);
  278.     END DrawArrow;
  279.     PROCEDURE Round(x: REAL): INTEGER;
  280.     BEGIN RETURN SHORT(ENTIER(x + 0.5))
  281.     END Round;
  282.     PROCEDURE (A: AttrLine) Draw* (F: KeplerPorts.Port);
  283.         CONST ArrLen = 44;
  284.         VAR a, b, h, v1, v2: REAL; x1, y1, x2, y2, ar, br: INTEGER;
  285.     BEGIN
  286.         x1 := A.p[0].x; y1 := A.p[0].y;
  287.         x2 := A.p[1].x; y2 := A.p[1].y;
  288.         a := x2 - x1; b := y2 - y1;
  289.         h := Math.sqrt(a*a + b*b);
  290.         IF h # 0 THEN
  291.             v1 := ArrLen * A.width / (4*3*h);
  292.             IF A.a1 = 1 THEN
  293.                 DrawArrow(F, A.p[0].x, A.p[0].y, A.p[1].x, A.p[1].y, ArrLen * A.width DIV 4, Math.pi / 6);
  294.                 x2 := x2 - Round(a * v1); y2 := y2 - Round(b * v1)
  295.             ELSIF A.a1 = 2 THEN
  296.                 DrawArrow(F, A.p[0].x, A.p[0].y, A.p[1].x, A.p[1].y, ArrLen * A.width DIV 6, Math.pi / 4);
  297.                 x2 := x2 - Round(a * v1); y2 := y2 - Round(b * v1)
  298.             END ;
  299.             IF A.a2 = 1 THEN
  300.                 DrawArrow(F, A.p[1].x, A.p[1].y, A.p[0].x, A.p[0].y, ArrLen * A.width DIV 4, Math.pi / 6);
  301.                 x1 := x1 + Round(a * v1); y1 := y1 + Round(b * v1)
  302.             END ;
  303.             IF A.width <= F.scale THEN (* draw as hair line *)
  304.                 F.DrawLine(x1, y1, x2, y2, Display.white, Display.replace)
  305.             ELSIF x1 = x2 THEN (* optimized drawing of vertical line *)
  306.                 IF y1 > y2 THEN F.FillRect(x1 - A.width DIV 2, y2, A.width, y1 - y2, fg, 5, Display.replace)
  307.                 ELSE F.FillRect(x1 - A.width DIV 2, y1, A.width, y2 - y1, fg, 5, Display.replace)
  308.                 END
  309.             ELSIF y1 = y2 THEN (* optimized drawing of horizontal line *)
  310.                 IF x1 > x2 THEN F.FillRect(x2, y2 - A.width DIV 2, x1 - x2, A.width, fg, 5, Display.replace)
  311.                 ELSE F.FillRect(x1, y1 - A.width DIV 2, x2 - x1, A.width, fg, 5, Display.replace)
  312.                 END
  313.             ELSE v2 := A.width / (2*h);
  314.                 ar := Round(a * v2); br := Round(b * v2);
  315.                 x1 := x1 DIV F.scale * F.scale; y1 := y1 DIV F.scale * F.scale;
  316.                 x2 := x2 DIV F.scale * F.scale; y2 := y2 DIV F.scale * F.scale;
  317.                 F.FillQuad(x1 - br, y1 + ar, x1 + br, y1 - ar, x2 - br, y2 + ar, x2 + br, y2 - ar, fg, 5, Display.replace)
  318.             END
  319.         END
  320.     END Draw;
  321.     PROCEDURE (A: AttrLine) Write* (VAR R: Files.Rider);
  322.     BEGIN Files.WriteNum(R, A.width); Files.WriteNum(R, A.a1); Files.WriteNum(R, A.a2); A.Write^(R)
  323.     END Write;
  324.     PROCEDURE (A: AttrLine) Read* (VAR R: Files.Rider);
  325.         VAR i: LONGINT;
  326.     BEGIN
  327.         Files.ReadNum(R, i); A.width := SHORT(i);
  328.         Files.ReadNum(R, i); A.a1 := SHORT(i);
  329.         Files.ReadNum(R, i); A.a2 := SHORT(i);
  330.         A.Read^(R)
  331.     END Read;
  332.     PROCEDURE NewAttrLine*;
  333.         VAR a: AttrLine; w, a1, a2: INTEGER;
  334.     BEGIN
  335.         IF KeplerFrames.nofpts >= 2 THEN
  336.             NEW(a); a.nofpts := 2;
  337.             In.Open; In.Int(w); In.Int(a1); In.Int(a2);
  338.             IF In.Done THEN 
  339.                 a.width := w; a.a1 := a1; a.a2 := a2;
  340.                 KeplerFrames.ConsumePoint(a.p[0]);
  341.                 KeplerFrames.ConsumePoint(a.p[1]);
  342.                 KeplerFrames.Focus.Append(a)
  343.             END
  344.         END
  345.     END NewAttrLine;
  346.     PROCEDURE ChangeAttrLine*;
  347.         VAR G: KeplerGraphs.Graph; c: KeplerGraphs.Constellation;
  348.             w, a1, a2: INTEGER;
  349.             F: KeplerPorts.BalloonPort;
  350.     BEGIN
  351.         In.Open;
  352.         In.Int(w); In.Int(a1); In.Int(a2);
  353.         KeplerFrames.GetSelection(G);
  354.         IF (G # NIL ) & In.Done THEN 
  355.             NEW(F); KeplerPorts.InitBalloon(F);
  356.             c := G.cons;
  357.             WHILE c # NIL DO
  358.                 WITH c: AttrLine DO
  359.                     IF c.State() = 2 THEN c.Draw(F); c.width := w; c.a1 := a1; c.a2 := a2 ; c.Draw(F) END
  360.                 ELSE
  361.                 END ;
  362.                 c := c.next
  363.             END ;
  364.             G.notify(KeplerGraphs.restore, G, NIL, F) 
  365.         END
  366.     END ChangeAttrLine;
  367. (* ------------------------------- Triangle ------------------------------- *)
  368.     PROCEDURE (T: Triangle) Draw* (F: KeplerPorts.Port);
  369.         VAR p0, p1, p2: KeplerGraphs.Star;
  370.     BEGIN p0 := T.p[0]; p1 := T.p[1]; p2 := T.p[2];
  371.         F.FillQuad(p0.x, p0.y, p1.x, p1.y, p2.x, p2.y, p2.x, p2.y, fg, T.pat, Display.replace)
  372.     END Draw;
  373.     PROCEDURE (T: Triangle) Write* (VAR R: Files.Rider);
  374.     BEGIN Files.WriteNum(R, T.pat); T.Write^(R)
  375.     END Write;
  376.     PROCEDURE (T: Triangle) Read* (VAR R: Files.Rider);
  377.         VAR i: LONGINT;
  378.     BEGIN Files.ReadNum(R, i); T.pat := SHORT (i); T.Read^(R)
  379.     END Read;
  380.     PROCEDURE NewTriangle*;
  381.         VAR o: Triangle; pat: INTEGER;
  382.     BEGIN
  383.         In.Open; In.Int(pat);
  384.         IF In.Done & (KeplerFrames.nofpts >= 3) THEN
  385.             NEW(o); o.nofpts := 3; o.pat := pat;
  386.             KeplerFrames.ConsumePoint(o.p[0]);
  387.             KeplerFrames.ConsumePoint(o.p[1]);
  388.             KeplerFrames.ConsumePoint(o.p[2]);
  389.             KeplerFrames.Focus.Append(o);
  390.         END
  391.     END NewTriangle;
  392. END Kepler1.
  393.